{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}

module Accessor where

import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import qualified Control.Monad.Trans.State as State
import Data.Tuple.Select
import Data.Tuple.Update


class Monad m => WithState m s | m -> s where
    getCurrentState :: m s
    setCurrentState :: s -> m ()


instance Monad m => WithState (State.StateT s m) s where
    getCurrentState = State.get
    setCurrentState = State.put


type Accessor a b = (a -> b, a -> b -> a)


getter :: Accessor a b -> a -> b
--------------------------------
getter = fst


setter :: Accessor a b -> a -> b -> a
-------------------------------------
setter = snd


get :: (Monad m, WithState m s) => Accessor s a -> m a
------------------------------------------------------
get acc = do s <- getCurrentState
             return $ getter acc s


set :: (Monad m, WithState m s) => Accessor s a -> a -> m ()
------------------------------------------------------------
set acc x = do s <- getCurrentState
               setCurrentState $ setter acc s x


with :: (Monad m, WithState m s) => Accessor s a -> (a -> b) -> m b
-------------------------------------------------------------------
with acc f = do x <- get acc
                return $ f x


update :: (Monad m, WithState m s) => Accessor s a -> (a -> a) -> m ()
----------------------------------------------------------------------
update acc f = do x <- get acc
                  set acc (f x)


state :: Accessor a a
---------------------
state = (get, set)
  where
    get = id
    set _ s = s


listHead :: Accessor [a] a
--------------------------
listHead = (get, set)
    where
      get (x:xs)   = x
      set (_:xs) x = x:xs


listTail :: Accessor [a] [a]
----------------------------
listTail = (get, set)
    where
      get (x:xs)    = xs
      set (x:_ ) xs = x:xs


listNth :: Int -> Accessor [a] a
--------------------------------
listNth n = (get n, set n)
    where
      get n xs = xs !! n
      set 0 (_:xs) x' = x' : xs
      set n (x:xs) x' = x : set (n - 1) xs x'


pairFst :: Accessor (a, b) a
----------------------------
pairFst = (get, set)
    where
      get (x, y)   = x
      set (_, y) x = (x, y)


pairSnd :: Accessor (a, b) b
----------------------------
pairSnd = (get, set)
    where
      get (x, y)   = y
      set (x, _) y = (x, y)


compose :: Accessor b c -> Accessor a b -> Accessor a c
-------------------------------------------------------
compose (get', set') (get, set) = (get' . get, aux)
    where
      aux a c = set a (set' (get a) c)


from :: Accessor b c -> Accessor a b -> Accessor a c
----------------------------------------------------
from = compose


fromN :: Accessor b c -> Accessor a [b] -> Accessor a [c]
---------------------------------------------------------
fromN (get, _) (get', _) = (map get . get', undefined)


class (Sel1 a b, Upd1 b a a) => Acc1 a b where
    acc1 :: Accessor a b

class (Sel2 a b, Upd2 b a a) => Acc2 a b where
    acc2 :: Accessor a b

class (Sel3 a b, Upd3 b a a) => Acc3 a b where
    acc3 :: Accessor a b

class (Sel4 a b, Upd4 b a a) => Acc4 a b where
    acc4 :: Accessor a b

class (Sel5 a b, Upd5 b a a) => Acc5 a b where
    acc5 :: Accessor a b

class (Sel6 a b, Upd6 b a a) => Acc6 a b where
    acc6 :: Accessor a b

class (Sel7 a b, Upd7 b a a) => Acc7 a b where
    acc7 :: Accessor a b

class (Sel8 a b, Upd8 b a a) => Acc8 a b where
    acc8 :: Accessor a b

class (Sel9 a b, Upd9 b a a) => Acc9 a b where
    acc9 :: Accessor a b

class (Sel10 a b, Upd10 b a a) => Acc10 a b where
    acc10 :: Accessor a b

class (Sel11 a b, Upd11 b a a) => Acc11 a b where
    acc11 :: Accessor a b

class (Sel12 a b, Upd12 b a a) => Acc12 a b where
    acc12 :: Accessor a b

class (Sel13 a b, Upd13 b a a) => Acc13 a b where
    acc13 :: Accessor a b

class (Sel14 a b, Upd14 b a a) => Acc14 a b where
    acc14 :: Accessor a b

class (Sel15 a b, Upd15 b a a) => Acc15 a b where
    acc15 :: Accessor a b


instance Acc1 (a1, a2) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2) a2 where
    acc2 = (sel2, flip upd2)

instance Acc1 (a1, a2, a3) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3) a3 where
    acc3 = (sel3, flip upd3)

instance Acc1 (a1, a2, a3, a4) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4) a4 where
    acc4 = (sel4, flip upd4)

instance Acc1 (a1, a2, a3, a4, a5) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4, a5) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4, a5) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4, a5) a4 where
    acc4 = (sel4, flip upd4)

instance Acc5 (a1, a2, a3, a4, a5) a5 where
    acc5 = (sel5, flip upd5)

instance Acc1 (a1, a2, a3, a4, a5, a6) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4, a5, a6) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4, a5, a6) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4, a5, a6) a4 where
    acc4 = (sel4, flip upd4)

instance Acc5 (a1, a2, a3, a4, a5, a6) a5 where
    acc5 = (sel5, flip upd5)

instance Acc6 (a1, a2, a3, a4, a5, a6) a6 where
    acc6 = (sel6, flip upd6)

instance Acc1 (a1, a2, a3, a4, a5, a6, a7) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4, a5, a6, a7) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4, a5, a6, a7) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4, a5, a6, a7) a4 where
    acc4 = (sel4, flip upd4)

instance Acc5 (a1, a2, a3, a4, a5, a6, a7) a5 where
    acc5 = (sel5, flip upd5)

instance Acc6 (a1, a2, a3, a4, a5, a6, a7) a6 where
    acc6 = (sel6, flip upd6)

instance Acc7 (a1, a2, a3, a4, a5, a6, a7) a7 where
    acc7 = (sel7, flip upd7)

instance Acc1 (a1, a2, a3, a4, a5, a6, a7, a8) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4, a5, a6, a7, a8) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4, a5, a6, a7, a8) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4, a5, a6, a7, a8) a4 where
    acc4 = (sel4, flip upd4)

instance Acc5 (a1, a2, a3, a4, a5, a6, a7, a8) a5 where
    acc5 = (sel5, flip upd5)

instance Acc6 (a1, a2, a3, a4, a5, a6, a7, a8) a6 where
    acc6 = (sel6, flip upd6)

instance Acc7 (a1, a2, a3, a4, a5, a6, a7, a8) a7 where
    acc7 = (sel7, flip upd7)

instance Acc8 (a1, a2, a3, a4, a5, a6, a7, a8) a8 where
    acc8 = (sel8, flip upd8)

instance Acc1 (a1, a2, a3, a4, a5, a6, a7, a8, a9) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4, a5, a6, a7, a8, a9) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4, a5, a6, a7, a8, a9) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4, a5, a6, a7, a8, a9) a4 where
    acc4 = (sel4, flip upd4)

instance Acc5 (a1, a2, a3, a4, a5, a6, a7, a8, a9) a5 where
    acc5 = (sel5, flip upd5)

instance Acc6 (a1, a2, a3, a4, a5, a6, a7, a8, a9) a6 where
    acc6 = (sel6, flip upd6)

instance Acc7 (a1, a2, a3, a4, a5, a6, a7, a8, a9) a7 where
    acc7 = (sel7, flip upd7)

instance Acc8 (a1, a2, a3, a4, a5, a6, a7, a8, a9) a8 where
    acc8 = (sel8, flip upd8)

instance Acc9 (a1, a2, a3, a4, a5, a6, a7, a8, a9) a9 where
    acc9 = (sel9, flip upd9)

instance Acc1 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a4 where
    acc4 = (sel4, flip upd4)

instance Acc5 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a5 where
    acc5 = (sel5, flip upd5)

instance Acc6 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a6 where
    acc6 = (sel6, flip upd6)

instance Acc7 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a7 where
    acc7 = (sel7, flip upd7)

instance Acc8 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a8 where
    acc8 = (sel8, flip upd8)

instance Acc9 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a9 where
    acc9 = (sel9, flip upd9)

instance Acc10 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a10 where
    acc10 = (sel10, flip upd10)

instance Acc1 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) a4 where
    acc4 = (sel4, flip upd4)

instance Acc5 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) a5 where
    acc5 = (sel5, flip upd5)

instance Acc6 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) a6 where
    acc6 = (sel6, flip upd6)

instance Acc7 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) a7 where
    acc7 = (sel7, flip upd7)

instance Acc8 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) a8 where
    acc8 = (sel8, flip upd8)

instance Acc9 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) a9 where
    acc9 = (sel9, flip upd9)

instance Acc10 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) a10 where
    acc10 = (sel10, flip upd10)

instance Acc11 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) a11 where
    acc11 = (sel11, flip upd11)

instance Acc1 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a4 where
    acc4 = (sel4, flip upd4)

instance Acc5 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a5 where
    acc5 = (sel5, flip upd5)

instance Acc6 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a6 where
    acc6 = (sel6, flip upd6)

instance Acc7 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a7 where
    acc7 = (sel7, flip upd7)

instance Acc8 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a8 where
    acc8 = (sel8, flip upd8)

instance Acc9 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a9 where
    acc9 = (sel9, flip upd9)

instance Acc10 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a10 where
    acc10 = (sel10, flip upd10)

instance Acc11 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a11 where
    acc11 = (sel11, flip upd11)

instance Acc12 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) a12 where
    acc12 = (sel12, flip upd12)

instance Acc1 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a4 where
    acc4 = (sel4, flip upd4)

instance Acc5 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a5 where
    acc5 = (sel5, flip upd5)

instance Acc6 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a6 where
    acc6 = (sel6, flip upd6)

instance Acc7 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a7 where
    acc7 = (sel7, flip upd7)

instance Acc8 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a8 where
    acc8 = (sel8, flip upd8)

instance Acc9 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a9 where
    acc9 = (sel9, flip upd9)

instance Acc10 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a10 where
    acc10 = (sel10, flip upd10)

instance Acc11 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a11 where
    acc11 = (sel11, flip upd11)

instance Acc12 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a12 where
    acc12 = (sel12, flip upd12)

instance Acc13 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) a13 where
    acc13 = (sel13, flip upd13)

instance Acc1 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a4 where
    acc4 = (sel4, flip upd4)

instance Acc5 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a5 where
    acc5 = (sel5, flip upd5)

instance Acc6 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a6 where
    acc6 = (sel6, flip upd6)

instance Acc7 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a7 where
    acc7 = (sel7, flip upd7)

instance Acc8 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a8 where
    acc8 = (sel8, flip upd8)

instance Acc9 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a9 where
    acc9 = (sel9, flip upd9)

instance Acc10 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a10 where
    acc10 = (sel10, flip upd10)

instance Acc11 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a11 where
    acc11 = (sel11, flip upd11)

instance Acc12 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a12 where
    acc12 = (sel12, flip upd12)

instance Acc13 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a13 where
    acc13 = (sel13, flip upd13)

instance Acc14 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) a14 where
    acc14 = (sel14, flip upd14)

instance Acc1 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a1 where
    acc1 = (sel1, flip upd1)

instance Acc2 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a2 where
    acc2 = (sel2, flip upd2)

instance Acc3 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a3 where
    acc3 = (sel3, flip upd3)

instance Acc4 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a4 where
    acc4 = (sel4, flip upd4)

instance Acc5 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a5 where
    acc5 = (sel5, flip upd5)

instance Acc6 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a6 where
    acc6 = (sel6, flip upd6)

instance Acc7 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a7 where
    acc7 = (sel7, flip upd7)

instance Acc8 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a8 where
    acc8 = (sel8, flip upd8)

instance Acc9 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a9 where
    acc9 = (sel9, flip upd9)

instance Acc10 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a10 where
    acc10 = (sel10, flip upd10)

instance Acc11 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a11 where
    acc11 = (sel11, flip upd11)

instance Acc12 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a12 where
    acc12 = (sel12, flip upd12)

instance Acc13 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a13 where
    acc13 = (sel13, flip upd13)

instance Acc14 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a14 where
    acc14 = (sel14, flip upd14)

instance Acc15 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) a15 where
    acc15 = (sel15, flip upd15)


data RecordInfo = RecordInfo { recordName            :: Name
                             , recordTypeParameters  :: [TyVarBndr]
                             , recordConstructorName :: Name
                             , recordFields          :: [(Name, Type)]
                             , recordAutoDerive      :: [Name]
                             }


infoFromRecordDeclaration :: Dec -> Q RecordInfo
------------------------------------------------
infoFromRecordDeclaration (DataD [] recordName typeParams [RecC constructorName constructorArguments] autoDerive) =
    do let fields = map extractField constructorArguments
       return $ RecordInfo recordName typeParams constructorName fields autoDerive
    where
      extractField (name, strict, typ) = (name, typ)
infoFromRecordDeclaration _ = do report True "Can only be used on record declarations"
                                 undefined


infoFromExistingDeclaration :: Dec -> [String] -> Q RecordInfo
--------------------------------------------------------------
infoFromExistingDeclaration (DataD [] typeName typeParams [NormalC constructorName fieldTypes] autoDerive) names =
    do if length names /= length fieldTypes
       then do report True "Need as many names as there are fields"
               undefined
       else do let fields = zip (map mkName names) (map snd fieldTypes)
               return $ RecordInfo typeName typeParams constructorName fields autoDerive
infoFromExistingDeclaration _ _ = do report True "Can only be used on data declarations with one constructor"
                                     undefined


typeDeclaration :: RecordInfo -> DecQ
-------------------------------------
typeDeclaration ri =
    do let args = map ((IsStrict, ) . snd) $ recordFields ri
       return $ DataD [] (recordName ri) (recordTypeParameters ri) [NormalC (recordConstructorName ri) args] (recordAutoDerive ri)



accessorSignature :: RecordInfo -> Int -> DecQ
----------------------------------------------
accessorSignature recordInfo fieldIndex =
    let field = recordFields recordInfo !! fieldIndex in
    let fieldName = fst field in
    let fieldType = snd field in
    let tparams = recordTypeParameters recordInfo in
    let recName = recordName recordInfo in
    let recType = foldl AppT (ConT recName) $ map (VarT . nameOfTyVarBndr) tparams in
    return $ SigD fieldName (ForallT tparams [] (AppT (AppT (ConT (mkName "Accessor.Accessor")) recType) fieldType))
        where
          nameOfTyVarBndr (PlainTV name) = name


accessorFunctions :: RecordInfo -> Int -> DecQ
----------------------------------------------
accessorFunctions ri k = do getter <- getterFunction
                            setter <- setterFunction k
                            let name = fst $ (recordFields ri) !! k
                            let body = NormalB $ TupE [ getter, setter ]
                            return $ ValD (VarP name) body []
    where
      argumentPattern = do names <- mapM (\_ -> newName "x") (recordFields ri)
                           let pattern = ConP (recordConstructorName ri) (map VarP names)
                           return (pattern, names)

      getterFunction = do (pattern, names) <- argumentPattern
                          return $ LamE [ pattern ] (VarE (names !! k))

      setterFunction k = do (pattern, names) <- argumentPattern
                            name <- newName "y"
                            let args = [ pattern, VarP name ]
                            let vars = map VarE names
                            let conArgs = take k vars ++ VarE name : drop (k + 1) vars
                            let expr = foldl AppE (ConE $ recordConstructorName ri) conArgs
                            let func = LamE args expr
                            return func


accessorDeclaration :: RecordInfo -> Int -> Q [Dec]
---------------------------------------------------
accessorDeclaration ri k = do sig <- accessorSignature ri k
                              val <- accessorFunctions ri k
                              return [ sig, val ]


accessorDeclarations :: RecordInfo -> Q [Dec]
---------------------------------------------
accessorDeclarations ri = liftM concat $ mapM (accessorDeclaration ri) [0..length (recordFields ri) - 1]


generateTypeAndAccessors :: RecordInfo -> Q [Dec]
-------------------------------------------------
generateTypeAndAccessors ri = do typeDec <- typeDeclaration ri
                                 accDecs <- accessorDeclarations ri
                                 return $ typeDec : accDecs



withAccessors :: Q [Dec] -> Q [Dec]
-----------------------------------
withAccessors declarations = do decls <- declarations
                                case decls of
                                  []       -> fail "Must receive exactly one record declaration"
                                  [ decl ] -> do info <- infoFromRecordDeclaration decl
                                                 generateTypeAndAccessors info
                                  (_:_:_)  -> fail "Must receive exactly one record declaration"
    where
      fail str = do report True str
                    return []



generateAccessors :: TypeQ -> [String] -> Q [Dec]
-------------------------------------------------
generateAccessors typq fieldNames = do typ <- typq
                                       case typ of
                                         ConT name -> do info <- reify name
                                                         case info of
                                                           TyConI dec -> do info <- infoFromExistingDeclaration dec fieldNames
                                                                            accessorDeclarations info
                                                           _ -> do report True "Given type must be a type constructor"
                                                                   undefined
                                         _ -> do report True "Given type must be a type constructor"
                                                 undefined
